perm filename INMRK.F4[NEW,LCS] blob sn#592315 filedate 1981-06-07 generic text, type T, neo UTF8
00100	C************ READX, NEWMRK, ISNUM, DOIT, MORMRK, 
00200	
00300		SUBROUTINE READX
00400		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /ALF/INP(72)/SCM/V(78)
00500		EQUIVALENCE (V(2),V2)
00600	C****320	REREAD 2430,J,R2,RJQ
00700	C  ↑↑↑ 1/78
00800		DO 2 K=2,72
00900		IF(INP(K).NE.'<')GO TO 2
01000		DO 3 J=K,72
01100	3	INP(J)=' '
01200		GO TO 4
01300	2	CONTINUE
01400	C CATCH '<' -- WHICH = COMMENT FOR REST OF LINE
01500	4	CALL RREAD(INP,V)
01600		JA=V(1)
01700		R2=V2
01800		DO 1 K=1,20
01900	1	RJQ(K)=V(K+2)
02000		END
02100	
02200		FUNCTION ISNUM(M)
02300	C ISNUM=0 IF M=A NUMBER.  ASSUMES A DOT MEANS DECIMAL POINT
02400		ISNUM=-1
02500		IF(M.EQ.'.')ISNUM=0
02600		IF(M.GE.'0'.AND.M.LE.'9')ISNUM=0 
02700		END
02800	
02900		SUBROUTINE NEWMRK(VX)
03000		DIMENSION VX(1)
03100		COMMON /DPY/ST(3690),N(1),N2,N3,JN(72),KN(172),RX(50),JJ,NN,MM
03200		1 /SC/A,B,C,D,E,NNN /ALF/INP(1) /MX/MX,MZ
03300		J=1
03400	34	J=J+1
03500	35	IF(ISNUM(INP(J)).NE.0)GO TO 30
03600			DO 31 MM=J+1,72
03700			M=INP(MM)
03800			IF(M.EQ.'/')GO TO 30
03900			IF(M.EQ.';')GO TO 30
04000			IF(M.EQ.'*')GO TO 30
04100			IF(M.NE.' ')GO TO 31
04200	C NOW FOUND SPACE AFTER NUMB.
04300				DO 32 J=MM+1,72
04400				M=INP(J)
04500				IF(M.EQ.' ')GO TO 32
04600				IF(ISNUM(M).NE.0)GO TO 30
04700	C FOUND SOMETHING, BUT NOT NUMB.
04800				INP(MM)=','
04900	C  FOUND NUMB, SO PUT IN COMMA
05000			
05100				IF(J.LT.72)GO TO 35
05200				GO TO 33
05300	32			CONTINUE
05400			GO TO 33
05500	31		CONTINUE
05600		GO TO 33
05700	30	IF(J.LT.72)GO TO 34
05800	33	MX=0
05900	C MX IS FLAG FOR LINE TOO LONG IN NEW FORMAT
06000		J=0
06100		MM=0
06200	10	JJ=0
06300		NN=0
06400		N2=0
06500	1	J=J+1
06600		IF(J.GT.72)GO TO 20
06700	C JUMP IF DONE
06800		M=INP(J)
06900	CURRENT CHARACTER
07000		IF(M.EQ.'-')GO TO 21
07100	C  '-' NEEDED FOR "C-" (DECRESC. SIGN)
07200		IF(M.LT.'A'.OR.M.GT.'Z')GO TO 2
07300	C JUMP IF A LETTER IS NOT FOUND
07400	21	JJ=JJ+1
07500		N(JJ)=M
07600		GO TO 1
07700	2	IF(M.EQ.' ')GO TO 1
07800	5	NN=NN+1
07900		JN(NN)=M
08000	C SAVE THE NUMBER CHARS.
08100	6	J=J+1
08200		M=INP(J)
08300	CC	IF(M.GE.'0'.AND.M.LE.'9')GO TO 5
08400	CC	IF(M.EQ.'.')GO TO 5
08500		IF(ISNUM(M).EQ.0)GO TO 5
08600	CXX	IF(M.NE.':')GO TO 22
08700		IF(M.NE.'!')GO TO 22
08800		M='-'
08900	C NEG. N2 WILL =TOTAL OF ITEMS STARTING WITH N1( /S 12!3/=/S 12:14/)
09000		NN=NN+1
09100		JN(NN)=' '
09200		GO TO 5
09300	22	IF(M.EQ.' ')GO TO 6
09400		IF(M.NE.':')GO TO 7
09500	C NOW A SEQUENCE OF ITEMS
09600		M=' '
09700		GO TO 5
09800	7	IF(M.NE.',')GO TO 8
09900	C NOW A SINGLE ITEM
10000		CALL DOIT
10100		NN=0
10200	C ITEM OR ITEMS NOW FINISHED
10300		GO TO 6
10400	8	IF(M.NE.'/')GO TO 11
10500		CALL DOIT
10600		GO TO 10
10700	11	IF(M.NE.';'.AND.M.NE.'*')GO TO 6
10800	C JUMP IF UNKNOWN CHAR.
10900		CALL DOIT
11000		KN(MM)=M
11100		IF(MM.LE.71)GO TO 20
11200	C SKIP IF REVISED LINE NOT TOO LONG
11300		MZ=MM
11400		DO 201 MM=71,1,-1
11500	201	IF(KN(MM).EQ.'/')GO TO 202
11600	202	MX=MM+1
11700	C POINTS TO START OF REMAINDER OF TOO-LONG LINE
11800		INP(72)=0
11900	20	CALL MORMRK(1,MM,VX)
12000		END
12100	
12200		SUBROUTINE DOIT
12300		COMMON /DPY/ST(3690),N(1),N2,N3,JN(72),KN(172),RX(50),JJ,NN,MM
12400		IF(N(1).NE.'C'.AND.N(1).NE.'O')GO TO 3
12500	CATCHES /C 5-7/C- 11.2-13.5/O 1-21/  ETC.
12600		IF(N2.EQ.'R')GO TO 3
12700	C JUMP IF "CR"  FOR WORD "CRESC."
12800		DO 4 K=1,NN
12900		MM=MM+1
13000		JX=JN(K)
13100		KN(MM)=JX
13200	4	IF(JX.EQ.' ')GO TO 5
13300	C  FIRST NUMBER COMPLETED
13400	5	DO 6 JX=1,JJ
13500		MM=MM+1
13600	6	KN(MM)=N(JX)
13700	CODE LETTER INSERTED
13800		MM=MM+1
13900		KN(MM)=' '
14000		DO 7 JX=K+1,NN
14100	C NOW PUT IN LAST NUMBER
14200		MM=MM+1
14300	7	KN(MM)=JN(JX)
14400		GO TO 8
14500	3	DO 1 K=1,NN
14600		MM=MM+1
14700	1	KN(MM)=JN(K)
14800		MM=MM+1
14900		KN(MM)=' '
15000		DO 2 K=1,JJ
15100		MM=MM+1
15200	2	KN(MM)=N(K)
15300	C NOW PUT IN THE CODE WORD
15400	8	MM=MM+1
15500		KN(MM)='/'
15600	CLOSE OFF THE ITEM
15700		END
15800	
15900	CC	SUBROUTINE MORMRK(VX)
16000		SUBROUTINE MORMRK(MA,MB,VX)
16100		DIMENSION VX(1)
16200		COMMON /DPY/ST(3690),N(1),N2,N3,JN(72),KN(172),RX(50),JO,NN,MM
16300		1 /SC/A,B,C,D,E,NNN /ALF/INP(1) /MX/MX,MZ
16400	CC	K=0
16500		MM=0
16600	C GET THE REST OF A TOO-LONG LINE
16700		DO 1 K=MA,MB
16800	CC	DO 1 J=MX,MZ
16900		MM=MM+1
17000	CC	K=K+1
17100	1	INP(MM)=KN(K)
17200	CC1	INP(K)=KN(J)
17300	CC	MM=K
17400		DO 13 K=MM+1,72
17500	13	INP(K)=' '
17600		IF(INP(MM).EQ.'*')INP(72)='*'
17700	C LINE ENDS WITH * OR ;
17800	C NOW GO FIX UP THE VX ARRAY.
17900	3	CALL RREAD(INP,VX)
18000		DO 23 K=1,50
18100		X=VX(K)
18200		IF(X.GT.0)Z=X
18300	C SAVE THE LAST POSITIVE NUM.
18400		IF(X.LT.0)VX(K)=-X+Z-1.
18500	C /S 17:5/=/S 17-21/ I.E. 5 NOTES STACCATO, STARTING WITH 17
18600	23	CONTINUE
18700	999	NNN=VX(1)
18800	CC	MX=0
18900		END